home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / debug-dump.lisp < prev    next >
Encoding:
Text File  |  1992-07-28  |  25.5 KB  |  775 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: debug-dump.lisp,v 1.30 92/07/14 03:41:23 wlott Locked $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file contains stuff that creates debugger information from the
  15. ;;; compiler's internal data structures.
  16. ;;; 
  17. ;;; Written by Rob MacLachlan
  18. ;;;
  19. (in-package 'c)
  20.  
  21. (defvar *byte-buffer*)
  22. (declaim (type (vector (unsigned-byte 8)) *byte-buffer*))
  23.  
  24.  
  25. ;;;; Debug blocks:
  26.  
  27. (deftype location-kind ()
  28.   '(member :unknown-return :known-return :internal-error :non-local-exit
  29.        :block-start :call-site :single-value-return :non-local-entry))
  30.  
  31.  
  32. ;;; The Location-Info structure holds the information what we need about
  33. ;;; locations which code generation decided were "interesting".
  34. ;;;
  35. (defstruct (location-info
  36.         (:constructor make-location-info (kind label vop)))
  37.   ;;
  38.   ;; The kind of location noted.
  39.   (kind nil :type location-kind)
  40.   ;;
  41.   ;; The label pointing to the interesting code location.
  42.   (label nil :type (or label index))
  43.   ;;
  44.   ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.)
  45.   (vop nil :type vop))
  46.  
  47.  
  48. ;;; NOTE-DEBUG-LOCATION  --  Interface
  49. ;;;
  50. ;;;    Called during code generation in places where there is an "interesting"
  51. ;;; location: some place where we are likely to end up in the debugger, and
  52. ;;; thus want debug info.
  53. ;;;
  54. (defun note-debug-location (vop label kind)
  55.   (declare (type vop vop) (type (or label index) label)
  56.        (type location-kind kind))
  57.   (setf (ir2-block-locations (vop-block vop))
  58.     (nconc (ir2-block-locations (vop-block vop))
  59.            (list (make-location-info kind label vop))))
  60.   (undefined-value))
  61.  
  62.  
  63. ;;; IR2-BLOCK-ENVIRONMENT  --  Interface
  64. ;;;
  65. (proclaim '(inline ir2-block-environment))
  66. (defun ir2-block-environment (2block)
  67.   (declare (type ir2-block 2block))
  68.   (block-environment (ir2-block-block 2block)))
  69.  
  70.  
  71. ;;; COMPUTE-LIVE-VARS  --  Internal
  72. ;;;
  73. ;;;    Given a local conflicts vector and an IR2 block to represent the set of
  74. ;;; live TNs, and the Var-Locs hash-table representing the variables dumped,
  75. ;;; compute a bit-vector representing the set of live variables.  If the TN is
  76. ;;; environment-live, we only mark it as live when it is in scope at Node.
  77. ;;;
  78. (defun compute-live-vars (live node block var-locs vop)
  79.   (declare (type ir2-block block) (type local-tn-bit-vector live)
  80.        (type hash-table var-locs) (type node node)
  81.        (type (or vop null) vop))
  82.   (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
  83.              :element-type 'bit
  84.              :initial-element 0))
  85.     (spilled (gethash vop
  86.               (ir2-component-spilled-vops
  87.                (component-info *compile-component*)))))
  88.     (do-live-tns (tn live block)
  89.       (let ((leaf (tn-leaf tn)))
  90.     (when (and (lambda-var-p leaf)
  91.            (or (not (member (tn-kind tn)
  92.                     '(:environment :debug-environment)))
  93.                (rassoc leaf (lexenv-variables (node-lexenv node))))
  94.            (or (null spilled)
  95.                (not (member tn spilled))))
  96.       (let ((num (gethash leaf var-locs)))
  97.         (when num
  98.           (setf (sbit res num) 1))))))
  99.     res))
  100.  
  101.  
  102. ;;; The PC for the location most recently dumped.
  103. ;;;
  104. (defvar *previous-location*)
  105. (proclaim '(type index *previous-location*))
  106.  
  107. ;;; DUMP-1-LOCATION  --  Internal
  108. ;;;
  109. ;;;    Dump a compiled debug-location into *BYTE-BUFFER* that describes the
  110. ;;; code/source map and live info.  If true, VOP is the VOP associated with
  111. ;;; this location, for use in determining whether TNs are spilled.
  112. ;;;
  113. (defun dump-1-location (node block kind tlf-num label live var-locs vop)
  114.   (declare (type node node) (type ir2-block block)
  115.        (type local-tn-bit-vector live)
  116.        (type (or label index) label)
  117.        (type location-kind kind) (type (or index null) tlf-num)
  118.        (type hash-table var-locs) (type (or vop null) vop))
  119.   
  120.   (vector-push-extend
  121.    (dpb (position kind compiled-code-location-kinds)
  122.     compiled-code-location-kind-byte
  123.     0)
  124.    *byte-buffer*)
  125.   
  126.   (let ((loc (if (fixnump label) label (label-position label))))
  127.     (write-var-integer (- loc *previous-location*) *byte-buffer*)
  128.     (setq *previous-location* loc))
  129.  
  130.   (let ((path (node-source-path node)))
  131.     (unless tlf-num
  132.       (write-var-integer (source-path-tlf-number path) *byte-buffer*))
  133.     (write-var-integer (source-path-form-number path) *byte-buffer*))
  134.   
  135.   (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
  136.                *byte-buffer*)
  137.   
  138.   (undefined-value))
  139.  
  140.  
  141. ;;; DUMP-LOCATION-FROM-INFO  --  Internal
  142. ;;;
  143. ;;;    Extract context info from a Location-Info structure and use it to dump a
  144. ;;; compiled code-location.
  145. ;;;
  146. (defun dump-location-from-info (loc tlf-num var-locs)
  147.   (declare (type location-info loc) (type (or index null) tlf-num)
  148.        (type hash-table var-locs))
  149.   (let ((vop (location-info-vop loc)))
  150.     (dump-1-location (vop-node vop)
  151.              (vop-block vop)
  152.              (location-info-kind loc)
  153.              tlf-num
  154.              (location-info-label loc)
  155.              (vop-save-set vop)
  156.              var-locs
  157.              vop))
  158.   (undefined-value))
  159.  
  160.  
  161. ;;; FIND-TLF-AND-BLOCK-NUMBERS  --  Internal
  162. ;;;
  163. ;;;    Scan all the blocks, caching the block numbering in the BLOCK-FLAG and
  164. ;;; determining if all locations are in the same TLF.
  165. ;;;
  166. (defun find-tlf-and-block-numbers (fun)
  167.   (declare (type clambda fun))
  168.   (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun))))
  169.     (num 0))
  170.     (declare (type index num) (type (or index null) res))
  171.     (do-environment-ir2-blocks (2block (lambda-environment fun))
  172.       (let ((block (ir2-block-block 2block)))
  173.     (when (eq (block-info block) 2block)
  174.       (setf (block-flag block) num)
  175.       (incf num)
  176.       (unless (eql (source-path-tlf-number
  177.             (node-source-path
  178.              (continuation-next
  179.               (block-start block))))
  180.                res)
  181.         (setq res nil)))
  182.     
  183.     (dolist (loc (ir2-block-locations 2block))
  184.       (unless (eql (source-path-tlf-number
  185.             (node-source-path
  186.              (vop-node (location-info-vop loc))))
  187.                res)
  188.         (setq res nil)))))
  189.     res))
  190.  
  191.  
  192. ;;; DUMP-BLOCK-LOCATIONS  --  Internal
  193. ;;;
  194. ;;;    Dump out the number of locations and the locations for Block.
  195. ;;;
  196. (defun dump-block-locations (block locations tlf-num var-locs)
  197.   (declare (type cblock block) (list locations))
  198.   (if (and locations
  199.        (eq (location-info-kind (first locations))
  200.            :non-local-entry))
  201.       (write-var-integer (length locations) *byte-buffer*)
  202.       (let ((2block (block-info block)))
  203.     (write-var-integer (+ (length locations) 1) *byte-buffer*)
  204.     (dump-1-location (continuation-next (block-start block))
  205.              2block :block-start tlf-num
  206.              (ir2-block-%label 2block)
  207.              (ir2-block-live-out 2block)
  208.              var-locs
  209.              nil)))
  210.   (dolist (loc locations)
  211.     (dump-location-from-info loc tlf-num var-locs))
  212.   (undefined-value))
  213.  
  214.  
  215. ;;; DUMP-BLOCK-SUCCESSORS  --  Internal
  216. ;;;
  217. ;;;    Dump the successors of Block, being careful not to fly into space on
  218. ;;; weird successors.
  219. ;;;
  220. (defun dump-block-successors (block env)
  221.   (declare (type cblock block) (type environment env))
  222.   (let* ((tail (component-tail (block-component block)))
  223.      (succ (block-succ block))
  224.      (valid-succ
  225.       (if (and succ
  226.            (or (eq (car succ) tail)
  227.                (not (eq (block-environment (car succ)) env))))
  228.           ()
  229.           succ)))
  230.     (vector-push-extend
  231.      (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
  232.      *byte-buffer*)
  233.     (dolist (b valid-succ)
  234.       (write-var-integer (block-flag b) *byte-buffer*)))
  235.   (undefined-value))
  236.  
  237.  
  238. ;;; COMPUTE-DEBUG-BLOCKS  --  Internal
  239. ;;;
  240. ;;;    Return a vector and an integer (or null) suitable for use as the BLOCKS
  241. ;;; and TLF-NUMBER in Fun's debug-function.  This requires three passes to
  242. ;;; compute:
  243. ;;; -- Scan all blocks, dumping the header and successors followed by all the
  244. ;;;    non-elsewhere locations.
  245. ;;; -- Dump the elsewhere block header and all the elsewhere locations (if
  246. ;;;    any.)
  247. ;;;
  248. (defun compute-debug-blocks (fun var-locs)
  249.   (declare (type clambda fun) (type hash-table var-locs))
  250.   (setf (fill-pointer *byte-buffer*) 0)
  251.   (let ((*previous-location* 0)
  252.     (tlf-num (find-tlf-and-block-numbers fun))
  253.     (env (lambda-environment fun))
  254.     (prev-locs nil)
  255.     (prev-block nil))
  256.     (collect ((elsewhere))
  257.       (do-environment-ir2-blocks (2block env)
  258.     (let ((block (ir2-block-block 2block)))
  259.       (when (eq (block-info block) 2block)
  260.         (when prev-block
  261.           (dump-block-locations prev-block prev-locs tlf-num var-locs))
  262.         (setq prev-block block  prev-locs ())
  263.         (dump-block-successors block env)))
  264.     
  265.     (collect ((here prev-locs))
  266.       (dolist (loc (ir2-block-locations 2block))
  267.         (if (label-elsewhere-p (location-info-label loc))
  268.         (elsewhere loc)
  269.         (here loc)))
  270.       (setq prev-locs (here))))
  271.  
  272.       (dump-block-locations prev-block prev-locs tlf-num var-locs)
  273.  
  274.       (when (elsewhere)
  275.     (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
  276.     (write-var-integer (length (elsewhere)) *byte-buffer*)
  277.     (dolist (loc (elsewhere))
  278.       (dump-location-from-info loc tlf-num var-locs))))
  279.  
  280.     (values (copy-seq *byte-buffer*) tlf-num)))
  281.  
  282.  
  283. ;;; DEBUG-SOURCE-FOR-INFO  --  Interface
  284. ;;;
  285. ;;;    Return a list of DEBUG-SOURCE structures containing information derived
  286. ;;; from Info.  We always dump the Start-Positions, since it is too hard
  287. ;;; figure out whether we need them or not.
  288. ;;;
  289. (defun debug-source-for-info (info)
  290.   (declare (type source-info info))
  291.   (assert (not (source-info-current-file info)))
  292.   (mapcar #'(lambda (x)
  293.           (let ((name (file-info-name x))
  294.             (res (make-debug-source
  295.               :from :file
  296.               :comment (file-info-comment x)
  297.               :created (file-info-write-date x)
  298.               :compiled (source-info-start-time info)
  299.               :source-root (file-info-source-root x)
  300.               :start-positions
  301.               (coerce-to-smallest-eltype
  302.                (file-info-positions x)))))
  303.         (cond ((simple-string-p name)
  304.                (setf (debug-source-name res) name))
  305.               (t
  306.                (setf (debug-source-from res) name)
  307.                (setf (debug-source-name res)
  308.                  (coerce (file-info-forms x) 'simple-vector))))
  309.         res))
  310.       (source-info-files info)))
  311.  
  312.  
  313. ;;; COERCE-TO-SMALLEST-ELTYPE  --  Internal
  314. ;;;
  315. ;;;    Given an arbirtary sequence, coerce it to an unsigned vector if
  316. ;;; possible.
  317. ;;;
  318. (defun coerce-to-smallest-eltype (seq)
  319.   (declare (type sequence seq))
  320.   (let ((max 0))
  321.     (declare (type (or index null) max))
  322.     (macrolet ((frob ()
  323.          '(if (and (typep val 'index) max)
  324.               (when (> val max)
  325.             (setq max val))
  326.               (setq max nil))))
  327.       (if (listp seq)
  328.       (dolist (val seq)
  329.         (frob))
  330.       (dotimes (i (length seq))
  331.         (let ((val (aref seq i)))
  332.           (frob)))))
  333.     
  334.     (if max
  335.     (coerce seq `(simple-array (integer 0 ,max)))
  336.     (coerce seq 'simple-vector))))
  337.  
  338.  
  339. ;;;; Variables:
  340.  
  341. ;;; TN-SC-OFFSET  --  Internal
  342. ;;;
  343. ;;;    Return a SC-OFFSET describing TN's location.
  344. ;;;
  345. (defun tn-sc-offset (tn)
  346.   (declare (type tn tn))
  347.   (make-sc-offset (sc-number (tn-sc tn))
  348.           (tn-offset tn)))
  349.  
  350.  
  351. ;;; DUMP-1-VARIABLE  --  Internal
  352. ;;;
  353. ;;;    Dump info to represent Var's location being TN.  ID is an integer that
  354. ;;; makes Var's name unique in the function.  Buffer is the vector we stick the
  355. ;;; result in.  If Minimal is true, we suppress name dumping, and set the
  356. ;;; minimal flag.
  357. ;;;
  358. ;;;    The debug-variable is only marked as always-live if the TN is
  359. ;;; environment live and is an argument.  If a :debug-environment TN, then we
  360. ;;; also exclude set variables, since the variable is not guranteed to be live
  361. ;;; everywhere in that case.
  362. ;;;
  363. (defun dump-1-variable (fun var tn id minimal buffer)
  364.   (declare (type lambda-var var) (type (or tn null) tn) (type index id)
  365.        (type clambda fun))
  366.   (let* ((name (leaf-name var))
  367.      (package (symbol-package name))
  368.      (package-p (and package (not (eq package *package*))))
  369.      (save-tn (and tn (tn-save-tn tn)))
  370.      (kind (and tn (tn-kind tn)))
  371.      (flags 0))
  372.     (declare (type index flags))
  373.     (cond (minimal
  374.        (setq flags (logior flags compiled-debug-variable-minimal-p))
  375.        (unless tn
  376.          (setq flags (logior flags compiled-debug-variable-deleted-p))))
  377.       (t
  378.        (unless package
  379.          (setq flags (logior flags compiled-debug-variable-uninterned)))
  380.        (when package-p
  381.          (setq flags (logior flags compiled-debug-variable-packaged)))))
  382.     (when (and (or (eq kind :environment)
  383.            (and (eq kind :debug-environment)
  384.             (null (basic-var-sets var))))
  385.            (not (gethash tn (ir2-component-spilled-tns
  386.                  (component-info *compile-component*))))
  387.            (eq (lambda-var-home var) fun))
  388.       (setq flags (logior flags compiled-debug-variable-environment-live)))
  389.     (when save-tn
  390.       (setq flags (logior flags compiled-debug-variable-save-loc-p)))
  391.     (unless (or (zerop id) minimal)
  392.       (setq flags (logior flags compiled-debug-variable-id-p)))
  393.     (vector-push-extend flags buffer)
  394.     (unless minimal
  395.       (write-var-string (symbol-name name) buffer)
  396.       (when package-p
  397.     (write-var-string (package-name package) buffer))
  398.       (unless (zerop id)
  399.     (write-var-integer id buffer)))
  400.     (if tn
  401.     (write-var-integer (tn-sc-offset tn) buffer)
  402.     (assert minimal))
  403.     (when save-tn
  404.       (write-var-integer (tn-sc-offset save-tn) buffer)))
  405.   (undefined-value))
  406.  
  407.  
  408. ;;; COMPUTE-VARIABLES  --  Internal
  409. ;;;
  410. ;;;    Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of Fun.
  411. ;;; Level is the current DEBUG-INFO quality.  Var-Locs is a hashtable in which
  412. ;;; we enter the translation from LAMBDA-VARS to the relative position of that
  413. ;;; variable's location in the resulting vector.
  414. ;;;
  415. (defun compute-variables (fun level var-locs)
  416.   (declare (type clambda fun) (type hash-table var-locs))
  417.   (collect ((vars))
  418.     (labels ((frob-leaf (leaf tn gensym-p)
  419.            (let ((name (leaf-name leaf)))
  420.          (when (and name (leaf-refs leaf) (tn-offset tn)
  421.                 (or gensym-p (symbol-package name)))
  422.            (vars (cons leaf tn)))))
  423.          (frob-lambda (x gensym-p)
  424.            (dolist (leaf (lambda-vars x))
  425.          (frob-leaf leaf (leaf-info leaf) gensym-p))))
  426.       (frob-lambda fun t)
  427.       (when (>= level 2)
  428.     (dolist (x (ir2-environment-environment
  429.             (environment-info (lambda-environment fun))))
  430.       (let ((thing (car x)))
  431.         (when (lambda-var-p thing)
  432.           (frob-leaf thing (cdr x) (= level 3)))))
  433.     
  434.     (dolist (let (lambda-lets fun))
  435.       (frob-lambda let (= level 3)))))
  436.     
  437.     (setf (fill-pointer *byte-buffer*) 0)
  438.     (let ((sorted (sort (vars) #'string<
  439.             :key #'(lambda (x)
  440.                  (symbol-name (leaf-name (car x))))))
  441.       (prev-name nil)
  442.       (id 0)
  443.       (i 0))
  444.       (declare (type (or simple-string null) prev-name)
  445.            (type index id i))
  446.       (dolist (x sorted)
  447.     (let* ((var (car x))
  448.            (name (symbol-name (leaf-name var))))
  449.       (cond ((and prev-name (string= prev-name name))
  450.          (incf id))
  451.         (t
  452.          (setq id 0  prev-name name)))
  453.       (dump-1-variable fun var (cdr x) id nil *byte-buffer*)
  454.       (setf (gethash var var-locs) i))
  455.     (incf i)))
  456.  
  457.     (copy-seq *byte-buffer*)))
  458.  
  459.  
  460. ;;; COMPUTE-MINIMAL-VARIABLES  --  Internal
  461. ;;;
  462. ;;;    Dump out the arguments to Fun in the minimal variable format.
  463. ;;;
  464. (defun compute-minimal-variables (fun)
  465.   (declare (type clambda fun))
  466.   (setf (fill-pointer *byte-buffer*) 0)
  467.   (dolist (var (lambda-vars fun))
  468.     (dump-1-variable fun var (leaf-info var) 0 t *byte-buffer*))
  469.   (copy-seq *byte-buffer*))
  470.  
  471.  
  472. ;;; DEBUG-LOCATION-FOR  --  Internal
  473. ;;;
  474. ;;;    Return Var's relative position in the function's variables (determined
  475. ;;; from the Var-Locs hashtable.)  If Var is deleted, the return DELETED.
  476. ;;;
  477. (defun debug-location-for (var var-locs)
  478.   (declare (type lambda-var var) (type hash-table var-locs))
  479.   (let ((res (gethash var var-locs)))
  480.     (cond (res)
  481.       (t
  482.        (assert (or (null (leaf-refs var))
  483.                (not (tn-offset (leaf-info var)))))
  484.        'deleted))))
  485.  
  486.  
  487. ;;;; Arguments/returns:
  488.  
  489. ;;; COMPUTE-ARGUMENTS  --  Internal
  490. ;;;
  491. ;;;    Return a vector to be used as the COMPILED-DEBUG-FUNCTION-ARGUMENTS for
  492. ;;; Fun.  If fun is the MAIN-ENTRY for an optional dispatch, then look at the
  493. ;;; ARGLIST to determine the syntax, otherwise pretend all arguments are fixed.
  494. ;;;
  495. ;;; ### This assumption breaks down in EPs other than the main-entry, since
  496. ;;; they may or may not have supplied-p vars, etc.
  497. ;;;
  498. (defun compute-arguments (fun var-locs)
  499.   (declare (type clambda fun) (type hash-table var-locs))
  500.   (collect ((res))
  501.     (let ((od (lambda-optional-dispatch fun)))
  502.       (if (and od (eq (optional-dispatch-main-entry od) fun))
  503.       (let ((actual-vars (lambda-vars fun))
  504.         (saw-optional nil))
  505.         (dolist (arg (optional-dispatch-arglist od))
  506.           (let ((info (lambda-var-arg-info arg))
  507.             (actual (pop actual-vars)))
  508.         (cond (info
  509.                (case (arg-info-kind info)
  510.              (:keyword
  511.               (res (arg-info-keyword info)))
  512.              (:rest
  513.               (res 'rest-arg))
  514.              (:optional
  515.               (unless saw-optional
  516.                 (res 'optional-args)
  517.                 (setq saw-optional t))))
  518.                (res (debug-location-for actual var-locs))
  519.                (when (arg-info-supplied-p info)
  520.              (res 'supplied-p)
  521.              (res (debug-location-for (pop actual-vars) var-locs))))
  522.               (t
  523.                (res (debug-location-for actual var-locs)))))))
  524.       (dolist (var (lambda-vars fun))
  525.         (res (debug-location-for var var-locs)))))
  526.  
  527.     (coerce-to-smallest-eltype (res))))
  528.  
  529.  
  530. ;;; COMPUTE-DEBUG-RETURNS  --  Internal
  531. ;;;
  532. ;;;    Return a vector of SC offsets describing Fun's return locations.  (Must
  533. ;;; be known values return...)
  534. ;;;
  535. (defun compute-debug-returns (fun)
  536.   (coerce-to-smallest-eltype 
  537.    (mapcar #'(lambda (loc)
  538.            (tn-sc-offset loc))
  539.        (return-info-locations (tail-set-info (lambda-tail-set fun))))))
  540.  
  541.  
  542. ;;;; Debug functions:
  543.  
  544. ;;; DFUN-FROM-FUN  --  Internal
  545. ;;;
  546. ;;;    Return a C-D-F structure with all the mandatory slots filled in.
  547. ;;;
  548. (defun dfun-from-fun (fun)
  549.   (declare (type clambda fun))
  550.   (let* ((2env (environment-info (lambda-environment fun)))
  551.      (dispatch (lambda-optional-dispatch fun))
  552.      (main-p (and dispatch
  553.               (eq fun (optional-dispatch-main-entry dispatch)))))
  554.     (make-compiled-debug-function
  555.      :name (cond ((leaf-name fun))
  556.          ((let ((ef (functional-entry-function
  557.                  fun)))
  558.             (and ef (leaf-name ef))))
  559.          ((and main-p (leaf-name dispatch)))
  560.          (t
  561.           (component-name
  562.            (block-component (node-block (lambda-bind fun))))))
  563.      :kind (if main-p nil (functional-kind fun))
  564.      :return-pc (tn-sc-offset (ir2-environment-return-pc 2env))
  565.      :old-fp (tn-sc-offset (ir2-environment-old-fp 2env))
  566.      :start-pc (label-position (ir2-environment-environment-start 2env))
  567.      :elsewhere-pc (label-position (ir2-environment-elsewhere-start 2env)))))
  568.  
  569.  
  570. ;;; COMPUTE-1-DEBUG-FUNCTION  --  Internal
  571. ;;;
  572. ;;;    Return a complete C-D-F structure for Fun.  This involves determining
  573. ;;; the DEBUG-INFO level and filling in optional slots as appropriate.
  574. ;;;
  575. (defun compute-1-debug-function (fun var-locs)
  576.   (declare (type clambda fun) (type hash-table var-locs))
  577.   (let* ((dfun (dfun-from-fun fun))
  578.      (level (cookie-debug
  579.          (lexenv-cookie (node-lexenv (lambda-bind fun))))))
  580.  
  581.     (cond ((zerop level))
  582.       ((and (<= level 1)
  583.         (let ((od (lambda-optional-dispatch fun)))
  584.           (or (not od)
  585.               (not (eq (optional-dispatch-main-entry od) fun)))))
  586.        (setf (compiled-debug-function-variables dfun)
  587.          (compute-minimal-variables fun))
  588.        (setf (compiled-debug-function-arguments dfun) :minimal))
  589.       (t
  590.        (setf (compiled-debug-function-variables dfun)
  591.          (compute-variables fun level var-locs))
  592.        (setf (compiled-debug-function-arguments dfun)
  593.          (compute-arguments fun var-locs))))
  594.     
  595.     (when (>= level 2)
  596.       (multiple-value-bind (blocks tlf-num)
  597.                (compute-debug-blocks fun var-locs)
  598.     (setf (compiled-debug-function-tlf-number dfun) tlf-num)
  599.     (setf (compiled-debug-function-blocks dfun) blocks)))
  600.  
  601.     (if (external-entry-point-p fun)
  602.     (setf (compiled-debug-function-returns dfun) :standard)
  603.     (let ((info (tail-set-info (lambda-tail-set fun))))
  604.       (when info
  605.         (cond ((eq (return-info-kind info) :unknown)
  606.            (setf (compiled-debug-function-returns dfun)
  607.              :standard))
  608.           ((/= level 0)
  609.            (setf (compiled-debug-function-returns dfun)
  610.              (compute-debug-returns fun)))))))
  611.     dfun))
  612.  
  613.  
  614. ;;;; Minimal debug functions:
  615.  
  616. ;;; DEBUG-FUNCTION-MINIMAL-P  --  Internal
  617. ;;;
  618. ;;;    Return true if Dfun can be represented as a minimal debug function.
  619. ;;; Dfun is a cons (<start offset> . C-D-F).
  620. ;;;
  621. (defun debug-function-minimal-p (dfun)
  622.   (declare (type cons dfun))
  623.   (let ((dfun (cdr dfun)))
  624.     (and (member (compiled-debug-function-arguments dfun) '(:minimal nil))
  625.      (null (compiled-debug-function-blocks dfun)))))
  626.  
  627.  
  628. ;;; DUMP-1-MINIMAL-DFUN  --  Internal
  629. ;;;
  630. ;;;    Dump a packed binary representation of a Dfun into *byte-buffer*.
  631. ;;; Prev-Start and Start are the byte offsets in the code where the previous
  632. ;;; function started and where this one starts.  Prev-Elsewhere is the previous
  633. ;;; function's elsewhere PC.
  634. ;;;
  635. (defun dump-1-minimal-dfun (dfun prev-start start prev-elsewhere)
  636.   (declare (type compiled-debug-function dfun)
  637.        (type index prev-start start prev-elsewhere))
  638.   (let* ((name (compiled-debug-function-name dfun))
  639.      (setf-p (and (consp name) (eq (car name) 'setf)
  640.               (consp (cdr name)) (symbolp (cadr name))))
  641.      (base-name (if setf-p (cadr name) name))
  642.      (pkg (when (symbolp base-name)
  643.         (symbol-package base-name)))
  644.      (name-rep
  645.       (cond ((stringp base-name)
  646.          minimal-debug-function-name-component)
  647.         ((not pkg)
  648.          minimal-debug-function-name-uninterned)
  649.         ((eq pkg *package*)
  650.          minimal-debug-function-name-symbol)
  651.         (t
  652.          minimal-debug-function-name-packaged))))
  653.     (assert (or (atom name) setf-p))
  654.     (let ((options 0))
  655.       (setf (ldb minimal-debug-function-name-style-byte options) name-rep)
  656.       (setf (ldb minimal-debug-function-kind-byte options)
  657.         (position (compiled-debug-function-kind dfun)
  658.               minimal-debug-function-kinds))
  659.       (setf (ldb minimal-debug-function-returns-byte options)
  660.         (etypecase (compiled-debug-function-returns dfun)
  661.           ((member :standard) minimal-debug-function-returns-standard)
  662.           ((member :fixed) minimal-debug-function-returns-fixed)
  663.           (vector minimal-debug-function-returns-specified)))
  664.       (vector-push-extend options *byte-buffer*))
  665.  
  666.     (let ((flags 0))
  667.       (when setf-p
  668.     (setq flags (logior flags minimal-debug-function-setf-bit)))
  669.       (when (compiled-debug-function-nfp dfun)
  670.     (setq flags (logior flags minimal-debug-function-nfp-bit)))
  671.       (when (compiled-debug-function-variables dfun)
  672.     (setq flags (logior flags minimal-debug-function-variables-bit)))
  673.       (vector-push-extend flags *byte-buffer*))
  674.  
  675.     (when (eql name-rep minimal-debug-function-name-packaged)
  676.       (write-var-string (package-name pkg) *byte-buffer*))
  677.     (unless (stringp base-name)
  678.       (write-var-string (symbol-name base-name) *byte-buffer*))
  679.  
  680.     (let ((vars (compiled-debug-function-variables dfun)))
  681.       (when vars
  682.     (let ((len (length vars)))
  683.       (write-var-integer len *byte-buffer*)
  684.       (dotimes (i len)
  685.         (vector-push-extend (aref vars i) *byte-buffer*)))))
  686.  
  687.     (let ((returns (compiled-debug-function-returns dfun)))
  688.       (when (vectorp returns)
  689.     (let ((len (length returns)))
  690.       (write-var-integer len *byte-buffer*)
  691.       (dotimes (i len)
  692.         (write-var-integer (aref returns i) *byte-buffer*)))))
  693.  
  694.     (write-var-integer (compiled-debug-function-return-pc dfun)
  695.                *byte-buffer*)
  696.     (write-var-integer (compiled-debug-function-old-fp dfun)
  697.                *byte-buffer*)
  698.     (when (compiled-debug-function-nfp dfun)
  699.       (write-var-integer (compiled-debug-function-nfp dfun)
  700.              *byte-buffer*))
  701.     (write-var-integer (- start prev-start) *byte-buffer*)
  702.     (write-var-integer (- (compiled-debug-function-start-pc dfun) start)
  703.                *byte-buffer*)
  704.     (write-var-integer (- (compiled-debug-function-elsewhere-pc dfun)
  705.               prev-elsewhere)
  706.                *byte-buffer*)))
  707.  
  708.  
  709. ;;; COMPUTE-MINIMAL-DEBUG-FUNCTIONS  --  Internal
  710. ;;;
  711. ;;;    Return a byte-vector holding all the debug functions for a component in
  712. ;;; the packed binary minimal-debug-function format.
  713. ;;;
  714. (defun compute-minimal-debug-functions (dfuns)
  715.   (declare (list dfuns))
  716.   (setf (fill-pointer *byte-buffer*) 0)
  717.   (let ((prev-start 0)
  718.     (prev-elsewhere 0))
  719.     (dolist (dfun dfuns)
  720.       (let ((start (car dfun))
  721.         (elsewhere (compiled-debug-function-elsewhere-pc (cdr dfun))))
  722.     (dump-1-minimal-dfun (cdr dfun) prev-start start prev-elsewhere)
  723.     (setq prev-start start  prev-elsewhere elsewhere))))
  724.   (copy-seq *byte-buffer*))
  725.  
  726.  
  727. ;;;; Full component dumping:
  728.  
  729. ;;; COMPUTE-DEBUG-FUNCTION-MAP  --  Internal
  730. ;;;
  731. ;;;    Compute the full form (simple-vector) function map.
  732. ;;;
  733. (defun compute-debug-function-map (sorted)
  734.   (declare (list sorted))
  735.   (let* ((len (1- (* (length sorted) 2)))
  736.      (funs-vec (make-array len)))
  737.     (do ((i -1 (+ i 2))
  738.      (sorted sorted (cdr sorted)))
  739.     ((= i len))
  740.       (declare (fixnum i))
  741.       (let ((dfun (car sorted)))
  742.     (unless (minusp i)
  743.       (setf (svref funs-vec i) (car dfun)))
  744.     (setf (svref funs-vec (1+ i)) (cdr dfun))))
  745.     funs-vec))
  746.  
  747.  
  748. ;;; DEBUG-INFO-FOR-COMPONENT  --  Interface
  749. ;;;
  750. ;;;    Return a debug-info structure describing component.  This has to be
  751. ;;; called after assembly so that source map information is available.
  752. ;;;
  753. (defun debug-info-for-component (component)
  754.   (declare (type component component))
  755.   (let ((res (make-compiled-debug-info :name (component-name component)
  756.                        :package (package-name *package*))))
  757.     (collect ((dfuns))
  758.       (let ((var-locs (make-hash-table :test #'eq))
  759.         (*byte-buffer* 
  760.          (make-array 10 :element-type '(unsigned-byte 8)
  761.              :fill-pointer 0  :adjustable t)))
  762.     (dolist (fun (component-lambdas component))
  763.       (clrhash var-locs)
  764.       (dfuns (cons (label-position
  765.             (block-label (node-block (lambda-bind fun))))
  766.                (compute-1-debug-function fun var-locs))))
  767.     
  768.     (let ((sorted (sort (dfuns) #'< :key #'car)))
  769.       (setf (compiled-debug-info-function-map res)
  770.         (if (every #'debug-function-minimal-p sorted)
  771.             (compute-minimal-debug-functions sorted)
  772.             (compute-debug-function-map sorted))))))
  773.  
  774.     res))
  775.